{-# LANGUAGE CPP, ScopedTypeVariables, OverloadedStrings #-}

#include <ghcplatform.h>

-- | Compiler utility functions, mainly dealing with IO and files
module Compiler.Utils
    (
      -- * File utils
      touchFile
    , copyNoOverwrite
    , writeBinaryFile
    , readBinaryFile
    , readBinaryFileL
    , findFile
    , jsexeExtension
    , addExeExtension
    , exeFileName
    , mkGhcjsSuf
    , mkGhcjsOutput
    , substPatterns
      -- * Source code and JS related utilities
    , ghcjsSrcSpan
    , isJsFile
      -- * User interaction
    , compilationProgressMsg
      -- * Environment
    , getEnvMay
    , getEnvOpt
      -- * Preprocessing for JS
    , doCpp
      -- * Error messages
    , simpleSrcErr
    ) where

import           DynFlags
import           GHC
import           GHC.Platform
import           HscTypes
import           Bag
-- import           FileCleanup
import           Module
import           Outputable        hiding ((<>))
import           ErrUtils          (mkPlainErrMsg)
import           Packages          (getPackageIncludePath, Version
                                   ,versionBranch, packageNameString
                                   ,packageVersion, lookupPackage
                                   ,explicitPackages, PackageConfig)
-- import           Config            (cProjectVersionInt)
import           Panic             (throwGhcExceptionIO)
import qualified SysTools
import           FileCleanup ( newTempName, TempFileLifetime(..) )
import           LlvmCodeGen ( llvmVersionList )
-- import           Panic

import qualified Control.Exception as Ex
import           Control.Monad
import           Control.Monad.IO.Class
import Prelude

import           Data.Char
import           Data.List         (isPrefixOf, isInfixOf, foldl', intercalate)
import           Data.Maybe        (mapMaybe)
import           Data.Text         (Text)
import qualified Data.Text         as T
import           Data.Version      (showVersion)

import           System.Directory  (doesFileExist, copyFile)
import           System.Environment
import           System.FilePath

import           Gen2.Utils

import qualified Data.ByteString as B
import           Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as BL

import           System.IO (withBinaryFile, Handle, IOMode(ReadMode, WriteMode))

import qualified Compiler.Platform as Platform

touchFile :: DynFlags -> FilePath -> IO ()
touchFile df file = do
  e <- doesFileExist file
  when e (SysTools.touch df "keep build system happy" file)

copyNoOverwrite :: FilePath -> FilePath -> IO ()
copyNoOverwrite from to = do
  ef <- doesFileExist from
  et <- doesFileExist to
  when (ef && not et) (copyFile from to)

findFile :: (FilePath -> FilePath)      -- Maps a directory path to a file path
         -> [FilePath]                  -- Directories to look in
         -> IO (Maybe FilePath)         -- The first file path to match
findFile _            [] = return Nothing
findFile mk_file_path (dir : dirs)
  = do let file_path = mk_file_path dir
       b <- doesFileExist file_path
       if b then return (Just file_path)
            else findFile mk_file_path dirs

{-
      macOS has trouble writing more than 2GiB at once to a file
  (tested with 10.14.6), and the base library doesn't work around this
  problem yet (tested with GHC 8.6), so we work around it here.

  in this workaround we write a binary file in chunks of 1 GiB
 -}
writeBinaryFile :: FilePath -> ByteString -> IO ()
writeBinaryFile file bs =
  withBinaryFile file WriteMode $ \h -> mapM_ (B.hPut h) (chunks bs)
  where
    -- split the ByteString into a nonempty list of chunks of at most 1GiB
    chunks :: ByteString -> [ByteString]
    chunks b =
      let (b1, b2) = B.splitAt 1073741824 b
      in  b1 : if B.null b1 then [] else chunks b2

readBinaryFile :: FilePath -> IO ByteString
readBinaryFile file = mconcat <$> readBinaryFileChunks file

readBinaryFileL :: FilePath -> IO BL.ByteString
readBinaryFileL file = BL.fromChunks <$> readBinaryFileChunks file

readBinaryFileChunks :: FilePath -> IO [ByteString]
readBinaryFileChunks file =
  withBinaryFile file ReadMode getChunks
  where
    getChunks :: Handle -> IO [ByteString]
    getChunks h = do
      chunk <- B.hGet h 1073741824
      if B.null chunk then pure [chunk]
                      else (chunk:) <$> getChunks h

jsexeExtension :: String
jsexeExtension = "jsexe"

addExeExtension :: FilePath -> FilePath
addExeExtension
  | Platform.isWindows = (<.> "exe")
  | otherwise          = id

exeFileName :: DynFlags -> FilePath
exeFileName dflags
  | Just s <- outputFile dflags =
      -- unmunge the extension
      let s' = dropPrefix "js_" (drop 1 $ takeExtension s)
      in if null s' || (Platform.isWindows && map toLower s' == "exe")
           then dropExtension s <.> jsexeExtension
           else dropExtension s <.> s'
  | otherwise =
      if platformOS (targetPlatform dflags) == OSMinGW32
           then "main.jsexe"
           else "a.jsexe"
  where
    dropPrefix prefix xs
      | prefix `isPrefixOf` xs = drop (length prefix) xs
      | otherwise              = xs

isJsFile :: FilePath -> Bool
isJsFile = (`elem` exts) . takeExtensions
  where
    exts = [".js", ".mjs", ".js.pp", ".mjs.pp" ]


mkGhcjsOutput :: String -> String
mkGhcjsOutput "" = ""
mkGhcjsOutput file
  | null ext         = file
  | ext == ".js"     = file
  | ext == ".hi"     = replaceExtension file ".js_hi"
  | ext == ".o"      = replaceExtension file ".js_o"
  | ext == ".dyn_hi" = replaceExtension file ".js_dyn_hi"
  | ext == ".dyn_o"  = replaceExtension file ".js_dyn_o"
  |  ".js_" `isPrefixOf` ext || "_js_" `isInfixOf` ext = file
  | otherwise        = replaceExtension file (".js_" ++ drop 1 ext)
  where
    ext = takeExtension file

mkGhcjsSuf :: String -> String
mkGhcjsSuf "o"      = "js_o"
mkGhcjsSuf "hi"     = "js_hi"
mkGhcjsSuf "dyn_o"  = "js_dyn_o"
mkGhcjsSuf "dyn_hi" = "js_dyn_hi"
mkGhcjsSuf xs | "js_" `isPrefixOf` xs || "_js_" `isInfixOf` xs = xs
mkGhcjsSuf xs       = "js_" ++ xs -- is this correct?

getEnvMay :: String -> IO (Maybe String)
getEnvMay xs = fmap Just (getEnv xs)
               `Ex.catch` \(_::Ex.SomeException) -> return Nothing

getEnvOpt :: MonadIO m => String -> m Bool
getEnvOpt xs = liftIO (maybe False ((`notElem` ["0","no"]).map toLower) <$> getEnvMay xs)

doCpp :: DynFlags -> Bool -> FilePath -> FilePath -> IO ()
doCpp dflags raw input_fn output_fn = do
    let hscpp_opts = picPOpts dflags
    let cmdline_include_paths = includePaths dflags

    pkg_include_dirs <- getPackageIncludePath dflags []
    let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) []
          (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs)
    let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) []
          (includePathsQuote cmdline_include_paths)
    let include_paths = include_paths_quote ++ include_paths_global

    let verbFlags = getVerbFlags dflags

    let cpp_prog args | raw       = SysTools.runCpp dflags args
                      | otherwise = SysTools.runCc Nothing dflags (SysTools.Option "-E" : args)


    let target_defs =
          [ "-D" ++ HOST_OS     ++ "_BUILD_OS=1",
            "-D" ++ HOST_ARCH   ++ "_BUILD_ARCH=1",
            "-Dghcjs_HOST_OS=1",
            "-Dghcjs_HOST_ARCH=1" ]
        -- remember, in code we *compile*, the HOST is the same our TARGET,
        -- and BUILD is the same as our HOST.

    -- profiling related definitions
    let prof_defs =
          if buildingProf dflags then ["-DGHCJS_PROF"] else []

    let sse_defs =
          [ "-D__SSE__"      | isSseEnabled      dflags ] ++
          [ "-D__SSE2__"     | isSse2Enabled     dflags ] ++
          [ "-D__SSE4_2__"   | isSse4_2Enabled   dflags ]

    let avx_defs =
          [ "-D__AVX__"      | isAvxEnabled      dflags ] ++
          [ "-D__AVX2__"     | isAvx2Enabled     dflags ] ++
          [ "-D__AVX512CD__" | isAvx512cdEnabled dflags ] ++
          [ "-D__AVX512ER__" | isAvx512erEnabled dflags ] ++
          [ "-D__AVX512F__"  | isAvx512fEnabled  dflags ] ++
          [ "-D__AVX512PF__" | isAvx512pfEnabled dflags ]

    backend_defs <- getBackendDefs dflags

    let th_defs = [ "-D__GLASGOW_HASKELL_TH__" ]
    -- Default CPP defines in Haskell source
    ghcVersionH <- getGhcVersionPathName dflags
    let hsSourceCppOpts = [ "-include", ghcVersionH ]

    -- MIN_VERSION macros
    let uids = explicitPackages (pkgState dflags)
        pkgs = mapMaybe (lookupPackage dflags) uids
    mb_macro_include <-
        if not (null pkgs) && gopt Opt_VersionMacros dflags
            then do macro_stub <- newTempName dflags TFL_CurrentModule "h"
                    writeFile macro_stub (generatePackageVersionMacros pkgs)
                    -- Include version macros for every *exposed* package.
                    -- Without -hide-all-packages and with a package database
                    -- size of 1000 packages, it takes cpp an estimated 2
                    -- milliseconds to process this file. See Trac #10970
                    -- comment 8.
                    return [SysTools.FileOption "-include" macro_stub]
            else return []

    cpp_prog       (   map SysTools.Option verbFlags
                    ++ map SysTools.Option include_paths
                    ++ map SysTools.Option hsSourceCppOpts
                    ++ map SysTools.Option target_defs
                    ++ map SysTools.Option prof_defs
                    ++ map SysTools.Option backend_defs
                    ++ map SysTools.Option th_defs
                    ++ map SysTools.Option hscpp_opts
                    ++ map SysTools.Option sse_defs
                    ++ map SysTools.Option avx_defs
                    ++ mb_macro_include
        -- Set the language mode to assembler-with-cpp when preprocessing. This
        -- alleviates some of the C99 macro rules relating to whitespace and the hash
        -- operator, which we tend to abuse. Clang in particular is not very happy
        -- about this.
                    ++ [ SysTools.Option     "-x"
                       , SysTools.Option     "assembler-with-cpp"
                       , SysTools.Option     input_fn
        -- We hackily use Option instead of FileOption here, so that the file
        -- name is not back-slashed on Windows.  cpp is capable of
        -- dealing with / in filenames, so it works fine.  Furthermore
        -- if we put in backslashes, cpp outputs #line directives
        -- with *double* backslashes.   And that in turn means that
        -- our error messages get double backslashes in them.
        -- In due course we should arrange that the lexer deals
        -- with these \\ escapes properly.
                       , SysTools.Option     "-o"
                       , SysTools.FileOption "" output_fn
                       ])

getBackendDefs :: DynFlags -> IO [String]
getBackendDefs dflags | hscTarget dflags == HscLlvm = do
    llvmVer <- SysTools.figureLlvmVersion dflags
    return $ case fmap llvmVersionList llvmVer of
               Just [m] -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,0) ]
               Just (m:n:_) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,n) ]
               _ -> []
  where
    format (major, minor)
      | minor >= 100 = error "getBackendDefs: Unsupported minor version"
      | otherwise = show $ (100 * major + minor :: Int) -- Contract is Int

getBackendDefs _ =
    return []

-- | Find out path to @ghcversion.h@ file
getGhcVersionPathName :: DynFlags -> IO FilePath
getGhcVersionPathName dflags = do
  candidates <- case ghcVersionFile dflags of
    Just path -> return [path]
    Nothing -> (map (</> "ghcversion.h")) <$>
               (getPackageIncludePath dflags [toInstalledUnitId rtsUnitId])

  found <- filterM doesFileExist candidates
  case found of
      []    -> throwGhcExceptionIO (InstallationError
                                    ("ghcversion.h missing; tried: "
                                      ++ intercalate ", " candidates))
      (x:_) -> return x

simpleSrcErr :: DynFlags -> SrcSpan -> String -> SourceError
simpleSrcErr df span msg = mkSrcErr (unitBag errMsg)
  where
    errMsg = mkPlainErrMsg df span (text msg)

-- | replace {abc} and {{abc}} patterns (case sensitive), {abc} replaced first
--   unknown {{abc}} patterns are replaced by the empty string
substPatterns :: [(Text,Text)] -- ^ replace {abc}   -> def
              -> [(Text,Text)] -- ^ replace {{abc}} -> def
              -> Text          -- ^ input
              -> Text          -- ^ result
substPatterns single double = unmatched
                            . f substDouble double
                            . f substSingle single
  where
    f g xs z = foldl' (flip g) z xs
    substSingle (var, val) = T.replace ("{"<>var<>"}") val
    substDouble (var, val) = T.replace ("{{"<>var<>"}}") val
    unmatched l | T.null b || T.null d = l
                | otherwise            = a <> unmatched d
          where (a,b)  = T.breakOn "{{" l
                (_c,d) = T.breakOn "}}" b

-- ---------------------------------------------------------------------------
-- Macros (cribbed from Cabal)

generatePackageVersionMacros :: [PackageConfig] -> String
generatePackageVersionMacros pkgs = concat
  -- Do not add any C-style comments. See Trac #3389.
  [ generateMacros "" pkgname version
  | pkg <- pkgs
  , let version = packageVersion pkg
        pkgname = map fixchar (packageNameString pkg)
  ]

fixchar :: Char -> Char
fixchar '-' = '_'
fixchar c   = c

generateMacros :: String -> String -> Version -> String
generateMacros prefix name version =
  concat
  ["#define ", prefix, "VERSION_",name," ",show (showVersion version),"\n"
  ,"#define MIN_", prefix, "VERSION_",name,"(major1,major2,minor) (\\\n"
  ,"  (major1) <  ",major1," || \\\n"
  ,"  (major1) == ",major1," && (major2) <  ",major2," || \\\n"
  ,"  (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")"
  ,"\n\n"
  ]
  where
    (major1:major2:minor:_) = map show (versionBranch version ++ repeat 0)
